home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / SWAG9605.DDD / 0020_PCX Viewer.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-05-31  |  4.6 KB  |  195 lines
  1. {
  2. Here you have the PCX source code. It works in 320x200 in 256 colors
  3. I still haven't study the SVGA modes.
  4.  
  5. I hope it could serves you.
  6.  
  7.  JL> Thanks in advance.
  8.  
  9. (In the other message i've send you the GIF routine (in two messages cos the
  10. extension)
  11.  
  12. ==============Cut===============================Cut========================}
  13.  
  14.       PROGRAM GPCX;      {Por: Javier Perez Vigo 1994}
  15.       USES Crt,graph,dos;
  16.       TYPE
  17.         PFich=^RFich;
  18.         RFich=Record
  19.           Size:Word;
  20.           Octeto:Array[0..64999] of Byte;
  21.           Sig:pFich;
  22.         End;
  23.       VAR
  24.         BORRA:FILE;
  25.         cadena:string[11];
  26.         f: text;
  27.        TECLA:BOOLEAN;
  28.        largo:integer;
  29.        muu:Longint;
  30.        ch:char;
  31.        Fich:File;
  32.        i,j,k:Integer;
  33.        a,b,c:Byte;
  34.        X,Y:Integer;
  35.        GD,GM,a14:Integer;
  36.        a17:LongInt;
  37.        s,F1:String;
  38.        Primero,Actual,Siguiente:PFich;
  39.        Count:Word;
  40.        Pall:Array[0..767] of Byte;
  41.        Reg:Registers;
  42.        {$F+}
  43.  
  44.        Procedure Inicia;assembler;
  45.         asm
  46.         mov ax,$13
  47.         int $10
  48.         end;
  49.  
  50.       FUNCTION EXISTE_ARCH(Nombre:STRING):BOOLEAN;
  51.          VAR
  52.            F:FILE;
  53.            OK:BOOLEAN;
  54.          BEGIN            { Existe_Arch }
  55.            Assign (f,Nombre);
  56.            {$I-}
  57.            Reset(f);
  58.            {$I+}
  59.            OK:=IOresult=0;
  60.            If Not OK then
  61.               Existe_Arch:=False
  62.             else
  63.               begin
  64.                 close(f);
  65.                 existe_Arch:=True;
  66.               end;        { else }
  67.          END;             { Existe_Arch }
  68.  
  69.        FUNCTION DetectVga256:integer;
  70.         begin
  71.         DetectVGA256:=1;
  72.         end;
  73.        {$F-}
  74.  
  75.    
  76.        PROCEDURE no_tecla;
  77.         var
  78.           cabeza_Tampon:integer absolute $0000:$041A;{cabeza actual}
  79.           cola_Tampon:integer absolute $0000:$041C;{cola actual}
  80.         begin
  81.            cola_Tampon:=cabeza_Tampon;
  82.         end;
  83.  
  84.  
  85.        BEGIN {Bloque principal}
  86.         clrscr;
  87.         wRITELn('   Utilidad de ficheros PCX');
  88.         F1:=ParamStr(1);
  89.        If Pos('.',F1)<1 THEN
  90.        F1:=F1+'.pcx';
  91.         Largo:=LENGTH(Paramstr(1));
  92.         if largo=0 then
  93.          begin
  94.           Textcolor(red);
  95.           writeLn('Escriba nombre de fichero');
  96.           TextColor(white);
  97.           textcolor(white);
  98.           writeLN;
  99.           halt(2)
  100.          end;
  101.        if not(existe_arch(f1)) then
  102.          BEGIN
  103.            TextColor(RED);
  104.            WriteLn(' ยก No existe el fichero ORIGEN ! ');
  105.            TextColor(WHITE);
  106.            writeLn;
  107.            Halt(3);
  108.          END
  109.       else
  110.       begin
  111.        INICIA;
  112.        gm:=0;
  113.        gd:=1;
  114.        initgraph(gd,gm,'c:\tp\bgi'); {the directory where the Unit is}
  115.        x:=0;y:=0;
  116.        Assign(Fich,F1);
  117.        Reset(Fich,1);
  118.        New(Actual);
  119.  
  120.        Primero:=Actual;
  121.        BlockRead(Fich,Actual^.Octeto,65000,Actual^.Size);
  122.        While not EOF(Fich) do
  123.         Begin
  124.          New(Siguiente);
  125.          Actual^.sig:=Siguiente;
  126.          Actual:=Siguiente;
  127.          BlockRead(Fich,Actual^.Octeto,65000,Actual^.Size);
  128.         End;
  129.        Actual^.Sig:=Nil;
  130.        Close(Fich);
  131.        For i:=0 to 255 do
  132.         Begin
  133.          SetPalette(i,i);
  134.          Pall[3*i]:=Actual^.Octeto[Actual^.Size-768+3*i] div 4;
  135.         Pall[3*i+1]:=Actual^.Octeto[Actual^.Size-767+3*i] div 4;
  136.         Pall[3*i+2]:=Actual^.Octeto[Actual^.Size-766+3*i] div 4;
  137.  
  138.         end;
  139.        reg.ax:=$1012;
  140.        reg.bx:=$00;
  141.        reg.cx:=$100;
  142.        reg.es:=seg(pall);
  143.        reg.dx:=ofs(pall);
  144.        Intr($10,reg);
  145.        Count:=128;
  146.        Actual:=Primero;
  147.        j:=0;
  148.       REPEAT
  149.       a:=Actual^.Octeto[Count];
  150.       Inc(Count);
  151.       if Count>Actual^.Size then
  152.        BEGIN
  153.          Actual:=Actual^.Sig;
  154.          Count:=0;
  155.        END;
  156.       If a>192 then
  157.       BEGIN
  158.         b:=a-192;
  159.         a:=Actual^.Octeto[Count];
  160.         Inc(Count);
  161.         If Count>Actual^.Size then
  162.         BEGIN
  163.           Actual:=Actual^.Sig;
  164.           Count:=0;
  165.         End;
  166.       END
  167.        else
  168.         b:=1;
  169.        While b<>0 do
  170.        begin
  171.          dec(b);
  172.          if a<>0 then
  173.            mem[$A000:320*Y+X]:=a;
  174.          Inc(X);
  175.          If X>319 then
  176.           begin
  177.             x:=0;
  178.             Inc(y);
  179.           end;
  180.         end;
  181.      Until(Actual^.sig=NIL) and (Actual^.size<768+count);
  182.          muu:=0;
  183.          repeat
  184.             NO_TECLA;
  185.             TECLA:=KEYPRESSED;
  186.             muu:=muu+1;
  187.          until (muu=150000) or TECLA;
  188.  
  189.        begin
  190.           textmode(c80);
  191.           Halt(4);
  192.         end;
  193.     end;
  194.   end.
  195.